home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_lf5.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  23.4 KB  |  955 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_lf5.c */
  5.  
  6. #include "clos.h"
  7.  
  8.  
  9.  
  10. /*** Predicati e funzioni logiche ***************************************/
  11. /* INTP    , REALP  , RATIOP  , SYSFUNCP , UFUNCP , ACCESSORP           */
  12. /* METHODP , CLASSP , ENAMEP  , CNAMEP   , STREAMP, MACROP        */
  13. /* SYMBOLP , CONSP  , VALUEP                          */
  14. /* ATOM    , LISTP  ,FUNCTIONP, NUMBERP    , ENDP     , EQUAL  , EQ    */
  15. /* ISZERO  , PLUSP  , MINUSP  , ODDP    , EVENP    , GREAT  , LESS      */
  16. /* NUMEQUAL, AND    , OR      , NOT     , IF       , WHEN   , UNLESS    */
  17. /************************************************************************/
  18.  
  19. /* Nota**************************************************/
  20. /* NULL           รจ tradotto in NOT            */
  21. /* >                   ,,        GREAT            */
  22. /* <                   ,,        LESS                   */
  23. /*                            */
  24. /* STRINGP,string=,STRING-EQUAL sono definite nei moduli*/
  25. /*                                       delle stringhe */
  26. /********************************************************/
  27.  
  28.  
  29. /* (IN EQUAL AGGIUNGERE SYSFUNC,UFUNC,ECC)                */
  30.  
  31. void lf_intp LF_PARAMS
  32. {
  33.  /* controlla se il nodo e' un integer  */
  34.  
  35.  if(IS_CONS(nin)){
  36.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  37.      nin=calc_pointer(nout);
  38.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_INTEGER)?T:NIL;
  39.      nout->type=P_ALLNODE;
  40.      return;
  41.  }
  42.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  43. }
  44.  
  45. void lf_realp LF_PARAMS
  46. {
  47.  /* controlla se il nodo e' un real    */
  48.  
  49.  if(IS_CONS(nin)){
  50.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  51.      nin=calc_pointer(nout);
  52.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_REAL)?T:NIL;
  53.      nout->type=P_ALLNODE;
  54.      return;
  55.  }
  56.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  57. }
  58.  
  59. void lf_ratiop LF_PARAMS
  60. {
  61.  /* controlla se il nodo e' un ratio    */
  62.  
  63.  if(IS_CONS(nin)){
  64.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  65.      nin=calc_pointer(nout);
  66.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_RATIO)?T:NIL;
  67.      nout->type=P_ALLNODE;
  68.      return;
  69.  }
  70.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  71. }
  72.  
  73. void lf_sysfuncp LF_PARAMS
  74. {
  75.  /* controlla se il nodo e' una sysfunc */
  76.  
  77.  if(IS_CONS(nin)){
  78.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  79.      nin=calc_pointer(nout);
  80.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_SYSFUNC)?T:NIL;
  81.      nout->type=P_ALLNODE;
  82.      return;
  83.  }
  84.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  85. }
  86.  
  87. void lf_ufuncp LF_PARAMS
  88. {
  89.  /* controlla se il nodo e' una sysfunc */
  90.  
  91.  if(IS_CONS(nin)){
  92.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  93.      nin=calc_pointer(nout);
  94.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_UFUNC)?T:NIL;
  95.      nout->type=P_ALLNODE;
  96.      return;
  97.  }
  98.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  99. }
  100.  
  101. void lf_accessorp LF_PARAMS
  102. {
  103.  /* controlla se il nodo e' una sysfunc */
  104.  
  105.  if(IS_CONS(nin)){
  106.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  107.      nin=calc_pointer(nout);
  108.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_ACCESSOR)?T:NIL;
  109.      nout->type=P_ALLNODE;
  110.      return;
  111.  }
  112.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  113. }
  114.  
  115. void lf_methodp LF_PARAMS
  116. {
  117.  /* controlla se il nodo e' una sysfunc */
  118.  
  119.  if(IS_CONS(nin)){
  120.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  121.      nin=calc_pointer(nout);
  122.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_METHOD)?T:NIL;
  123.      nout->type=P_ALLNODE;
  124.      return;
  125.  }
  126.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  127. }
  128.  
  129. void lf_classp LF_PARAMS
  130. {
  131.  /* controlla se il nodo e' una classe */
  132.  
  133.  if(IS_CONS(nin)){
  134.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  135.      nin=calc_pointer(nout);
  136.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_CLASS)?T:NIL;
  137.      nout->type=P_ALLNODE;
  138.      return;
  139.  }
  140.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  141. }
  142.  
  143. void lf_cnamep LF_PARAMS
  144. {
  145.  /* controlla se il nodo e' un cname  ( :nodo )  */
  146.  
  147.  if(IS_CONS(nin)){
  148.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  149.      nin=calc_pointer(nout);
  150.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_CNAME)?T:NIL;
  151.      nout->type=P_ALLNODE;
  152.      return;
  153.  }
  154.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  155. }
  156.  
  157. void lf_enamep LF_PARAMS
  158. {
  159.  /* controlla se il nodo e' un ename  ( &nodo )  */
  160.  
  161.  if(IS_CONS(nin)){
  162.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  163.      nin=calc_pointer(nout);
  164.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_ENAME)?T:NIL;
  165.      nout->type=P_ALLNODE;
  166.      return;
  167.  }
  168.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  169. }
  170.  
  171. void lf_streamp LF_PARAMS
  172. {
  173.  /* controlla se il nodo e' uno stream */
  174.  
  175.  if(IS_CONS(nin)){
  176.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  177.      nin=calc_pointer(nout);
  178.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_STREAM)?T:NIL;
  179.      nout->type=P_ALLNODE;
  180.      return;
  181.  }
  182.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  183. }
  184.  
  185. void lf_macrop LF_PARAMS
  186. {
  187.  /* controlla se il nodo e' una macro */
  188.  
  189.  if(IS_CONS(nin)){
  190.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  191.      nin=calc_pointer(nout);
  192.      nout->node=(IS_VALUE(nin)&&GET_VTYPE(nin)==NT_MACRO)?T:NIL;
  193.      nout->type=P_ALLNODE;
  194.      return;
  195.  }
  196.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  197. }
  198.  
  199.  
  200. void lf_symbolp LF_PARAMS
  201. {
  202.  /* controlla se il nodo e' un simbolo (T) */
  203.  
  204.  if(IS_CONS(nin)){
  205.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  206.      nout->node=IS_NAME(calc_pointer(nout))?T:NIL;
  207.      nout->type=P_ALLNODE;
  208.      return;
  209.  }
  210.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  211. }
  212.  
  213.  
  214. void lf_consp LF_PARAMS
  215. {
  216.  /* controlla se il nodo e' CONS (T) */
  217.  
  218.  if(IS_CONS(nin)){
  219.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  220.      nout->node=IS_CONS(calc_pointer(nout))?T:NIL;
  221.      nout->type=P_ALLNODE;
  222.      return;
  223.  }
  224.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  225. }
  226.  
  227. void lf_valuep LF_PARAMS
  228. {
  229.  /* controlla se il nodo e' un nodo-valore (T) */
  230.  
  231.  if(IS_CONS(nin)){
  232.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  233.      nout->node=IS_VALUE(calc_pointer(nout))?T:NIL;
  234.      nout->type=P_ALLNODE;
  235.      return;
  236.  }
  237.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  238. }
  239.  
  240. /*-------------------------------------------------------------------------*/
  241.  
  242. void lf_atom LF_PARAMS
  243. {
  244.  if(IS_CONS(nin)){
  245.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  246.     nout->node=IS_CONS(calc_pointer(nout))?NIL:T;
  247.     nout->type=P_ALLNODE;
  248.     return;
  249.  }
  250.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nin);
  251. }
  252.  
  253. void lf_listp LF_PARAMS
  254. {
  255.  /* controlla se il nodo e' CONS o NIL (T) */
  256.  
  257.  if(IS_CONS(nin)){
  258.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  259.      nin=calc_pointer(nout);
  260.      nout->node=(IS_CONS(nin)||nin==NIL)?T:NIL;
  261.      nout->type=P_ALLNODE;
  262.      return;
  263.  }
  264.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  265. }
  266.  
  267. void lf_functionp LF_PARAMS
  268. {
  269.  /* controlla se il nodo e' una funzione */
  270.  REGISTER_MOD n_type t;
  271.  
  272.  if(IS_CONS(nin)){
  273.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  274.      nin=calc_pointer(nout);
  275.      nout->type=P_ALLNODE;
  276.      if(IS_VALUE(nin)){
  277.        t=GET_VTYPE(nin);
  278.        if(t==NT_SYSFUNC||t==NT_UFUNC||t==NT_METHOD||t==NT_ACCESSOR){
  279.      nout->node=T;
  280.      return;
  281.        }
  282.      }
  283.      nout->node=NIL;
  284.      return;
  285.  }
  286.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  287. }
  288.  
  289. void lf_numberp LF_PARAMS
  290. {
  291.  /* controlla se il nodo e' un numero */
  292.  
  293.  if(IS_CONS(nin)){
  294.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  295.      nin=calc_pointer(nout);
  296.      nout->node=IS_VALUE_AND_NUMBER(nin)?T:NIL;
  297.      nout->type=P_ALLNODE;
  298.      return;
  299.  }
  300.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  301. }
  302.  
  303. void lf_endp LF_PARAMS
  304. {
  305.  /* controlla se il nodo e' CONS (T) o NIL (NIL) */
  306.  
  307.  if(IS_CONS(nin)){
  308.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  309.      if((nin=calc_pointer(nout))==NIL){
  310.     nout->type=P_ALLNODE;
  311.     nout->node=T;
  312.     return;
  313.      }
  314.      if(IS_CONS(nin)){
  315.     nout->type=P_ALLNODE;
  316.     nout->node=NIL;
  317.     return;
  318.      }
  319.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  320.  }
  321.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  322. }
  323.  
  324. int compare_nodes();
  325. void lf_equal LF_PARAMS
  326. {
  327.  node value1;
  328.  if(IS_CONS(nin)){
  329.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  330.    value1=calc_pointer(nout);
  331.    if(IS_CONS(CONSRIGHT(nin))){
  332.      while(IS_CONS(nin=CONSRIGHT(nin))){
  333.        eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  334.        if(!compare_nodes(value1,calc_pointer(nout))){
  335.      nout->node=NIL;
  336.      nout->type=P_ALLNODE;
  337.      return;
  338.        }
  339.      }
  340.      nout->node=T;
  341.      nout->type=P_ALLNODE;
  342.      return;
  343.    }
  344.    error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  345.  }
  346.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  347. }
  348.  
  349. #define EQUAL 1
  350. #define NEQUAL 0
  351.  
  352. int compare_nodes(n1,n2)
  353. node n1;
  354. node n2;
  355. {
  356.  if(GET_NTYPE(n1)!=GET_NTYPE(n2))return NEQUAL;
  357.  switch(GET_NTYPE(n1)){
  358.    case NT_IS_CONS:
  359.      return
  360.        compare_nodes(CONSLEFT(n1),CONSLEFT(n2))&&
  361.        compare_nodes(CONSRIGHT(n1),CONSRIGHT(n2));
  362.    case NT_IS_NAME:
  363.      return n1==n2;
  364.    case NT_IS_VALUE:
  365.      if(GET_VTYPE(n1)!=GET_VTYPE(n2))return NEQUAL;
  366.      switch(GET_VTYPE(n1)){
  367.        case NT_INTEGER:
  368.      return INTEGER(n1)==INTEGER(n2);
  369.        case NT_REAL:
  370.      return REAL(n1)==REAL(n2);
  371.        case NT_RATIO:
  372.      return
  373.        (RATIO_NUM(n1)==RATIO_NUM(n2))&&
  374.        (RATIO_DEN(n1)==RATIO_DEN(n2));
  375.        case NT_STRING:
  376.      return
  377.        !strcmp(string_get(STRING(n1),buf1),string_get(STRING(n2),buf2));
  378.        case NT_CNAME:
  379.      return compare_nodes(CNAME(n1),CNAME(n2));
  380.        case NT_ENAME:
  381.      return compare_nodes(ENAME(n1),ENAME(n2));
  382.        case NT_STREAM:
  383.      return STREAM(n1)==STREAM(n2);
  384.      }
  385.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n1);
  386.    }
  387.    return 0;
  388. }
  389.  
  390. void lf_eq LF_PARAMS
  391. {
  392.  node p1;
  393.  if(IS_CONS(nin)){
  394.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  395.    p1=calc_pointer(nout);
  396.    if(IS_CONS(CONSRIGHT(nin))){
  397.      while(IS_CONS(nin=CONSRIGHT(nin))){
  398.        eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  399.        if(calc_pointer(nout)!=p1){
  400.          nout->node=NIL;
  401.          nout->type=P_ALLNODE;
  402.          return;
  403.        }
  404.      }
  405.      nout->type=P_ALLNODE;
  406.      nout->node=T;
  407.      return;
  408.    }
  409.    error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  410.  }
  411.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  412. }
  413.  
  414.  
  415.  
  416. /************************************************************************/
  417.  
  418. void lf_iszero LF_PARAMS
  419. {
  420.  /* controlla se il nodo e' un numero e se e' zero */
  421.  if(IS_CONS(nin)){
  422.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  423.     nin=calc_pointer(nout);
  424.     nout->type=P_ALLNODE;
  425.     if(IS_VALUE(nin)){
  426.     switch(GET_VTYPE(nin)){
  427.         case NT_INTEGER:
  428.             nout->node=INTEGER(nin)?NIL:T;
  429.             return;
  430.         case NT_RATIO:
  431.             nout->node=RATIO_NUM(nin)?NIL:T;
  432.             return;
  433.         case NT_REAL:
  434.             nout->node=REAL(nin)?NIL:T;
  435.             return;
  436.     }
  437.     }
  438.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  439.  }
  440.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  441. }
  442.  
  443. void lf_plusp LF_PARAMS
  444. {
  445.  if(IS_CONS(nin)){
  446.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  447.     if(IS_VALUE_AND_NUMBER(nin=calc_pointer(nout))){
  448.     nout->type=P_ALLNODE;
  449.     switch(GET_VTYPE(nin)){
  450.         case NT_INTEGER:
  451.         nout->node=INTEGER(nin)>0?T:NIL;
  452.         return;
  453.         case NT_REAL:
  454.         nout->node=REAL(nin)>0?T:NIL;
  455.         return;
  456.         case NT_RATIO:
  457.         nout->node=(RATIO_NUM(nin)>0)^(RATIO_DEN(nin)>0)?NIL:T;
  458.         return;
  459.     }
  460.     }
  461.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  462.  }
  463.  error(E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  464. }
  465.  
  466. void lf_minusp LF_PARAMS
  467. {
  468.  if(IS_CONS(nin)){
  469.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  470.     if(IS_VALUE_AND_NUMBER(nin=calc_pointer(nout))){
  471.         nout->type=P_ALLNODE;
  472.     switch(GET_VTYPE(nin)){
  473.         case NT_INTEGER:
  474.                 nout->node=INTEGER(nin)<0?T:NIL;
  475.         return;
  476.         case NT_REAL:
  477.                 nout->node=REAL(nin)<0?T:NIL;
  478.                 return;
  479.             case NT_RATIO:
  480.         nout->node=(RATIO_NUM(nin)>0)^(RATIO_DEN(nin)>0)?T:NIL;
  481.                 return;
  482.         }
  483.     }
  484.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  485.  }
  486.  error(E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  487. }
  488.  
  489. void lf_oddp LF_PARAMS
  490. {
  491.  if(IS_CONS(nin)){
  492.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  493.     nin=calc_pointer(nout);
  494.     if(IS_VALUE_AND_NUMBER(nin)&&GET_VTYPE(nin)==NT_INTEGER){
  495.     nout->type=P_ALLNODE;
  496.     nout->node=INTEGER(nin)&1?T:NIL;
  497.     return;
  498.     }
  499.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  500.  }
  501.  error(E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  502. }
  503.  
  504. void lf_evenp LF_PARAMS
  505. {
  506.  if(IS_CONS(nin)){
  507.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  508.     nin=calc_pointer(nout);
  509.     if(IS_VALUE_AND_NUMBER(nin)&&GET_VTYPE(nin)==NT_INTEGER){
  510.         nout->type=P_ALLNODE;
  511.         nout->node=INTEGER(nin)&1?NIL:T;
  512.     return;
  513.     }
  514.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  515.  }
  516.  error(E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  517. }
  518.  
  519. #define TF_FIRST 0
  520. #define TF_INT   1
  521. #define TF_RAT   2
  522. #define TF_FLO   3
  523.  
  524. void lf_less LF_PARAMS
  525. {
  526.  /* controlla se gli argomenti sono in ordine strettamente crescente */
  527.  
  528.  REGISTER_MOD int    type_flag=TF_FIRST;
  529.  REGISTER_MOD n_type t;
  530.  n_int  last_int;
  531.  n_real last_real;
  532.  n_real tmp;
  533.  node    n;
  534.  
  535.    while(IS_CONS(nin)){
  536.       eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  537.       if( (t=TYPE(n=calc_pointer(nout)))&NT_IS_VALUE){
  538.      switch(t&NT_MASK){
  539.          case NT_INTEGER:
  540.         switch(type_flag){
  541.            case TF_FIRST:
  542.               type_flag=TF_INT;
  543.               last_int=INTEGER(n);
  544.               nin=CONSRIGHT(nin);
  545.               continue;
  546.            case TF_INT:
  547.               if(last_int<INTEGER(n)){
  548.                         last_int=INTEGER(n);
  549.                         nin=CONSRIGHT(nin);
  550.                         continue;
  551.                       }
  552.                       nout->node=NIL;
  553.                       nout->type=P_ALLNODE;
  554.                       return;
  555.            case TF_FLO:
  556.               if(last_real<(n_real)INTEGER(n)){
  557.                         last_real=(n_real)INTEGER(n);
  558.                         nin=CONSRIGHT(nin);
  559.                         continue;
  560.               }
  561.               nout->node=NIL;
  562.                       nout->type=P_ALLNODE;
  563.                       return;
  564.         }
  565.              case NT_RATIO:
  566.                 switch(type_flag){
  567.            case TF_FIRST:
  568.                       last_real=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  569.                       type_flag=TF_FLO;
  570.                       nin=CONSRIGHT(nin);
  571.                       continue;
  572.                    case TF_INT:
  573.                       last_real=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  574.                       if((n_real)last_int<last_real){
  575.             type_flag=TF_FLO;
  576.             nin=CONSRIGHT(nin);
  577.                         continue;
  578.                       }
  579.                       nout->node=NIL;
  580.               nout->type=P_ALLNODE;
  581.               return;
  582.                    case TF_FLO:
  583.                       tmp=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  584.               if(last_real<tmp){
  585.                         last_real=tmp;
  586.                         nin=CONSRIGHT(nin);
  587.             continue;
  588.                       }
  589.                       nout->node=NIL;
  590.                       nout->type=P_ALLNODE;
  591.                       return;
  592.                 }
  593.              case NT_REAL:
  594.                 switch(type_flag){
  595.            case TF_FIRST:
  596.               last_real=REAL(n);
  597.                       type_flag=TF_FLO;
  598.                       nin=CONSRIGHT(nin);
  599.                       continue;
  600.            case TF_INT:
  601.               if((n_real)last_int<REAL(n)){
  602.                         last_real=REAL(n);
  603.                         type_flag=TF_FLO;
  604.             nin=CONSRIGHT(nin);
  605.                         continue;
  606.                       }
  607.               nout->node=NIL;
  608.                       nout->type=P_ALLNODE;
  609.                       return;
  610.                    case TF_FLO:
  611.                       if(last_real<REAL(n)){
  612.                         last_real=REAL(n);
  613.                         nin=CONSRIGHT(nin);
  614.                         continue;
  615.               }
  616.               nout->node=NIL;
  617.                       nout->type=P_ALLNODE;
  618.                       return;
  619.                 }
  620.          default:
  621.            error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  622.          }/* switch */
  623.       }/* if is-value */
  624.       error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  625.    }/* while */
  626.  nout->type=P_ALLNODE;
  627.  nout->node=T;
  628. }
  629.  
  630. void lf_great LF_PARAMS
  631. {
  632.  /* controlla se gli argomenti sono in ordine strettamente crescente */
  633.  
  634.  REGISTER_MOD int    type_flag=TF_FIRST;
  635.  REGISTER_MOD n_type t;
  636.  n_int  last_int;
  637.  n_real last_real;
  638.  n_real tmp;
  639.  node    n;
  640.  
  641.    while(IS_CONS(nin)){
  642.       eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  643.       if( (t=TYPE(n=calc_pointer(nout)))&NT_IS_VALUE){
  644.      switch(t&NT_MASK){
  645.              case NT_INTEGER:
  646.                 switch(type_flag){
  647.            case TF_FIRST:
  648.               type_flag=TF_INT;
  649.               last_int=INTEGER(n);
  650.               nin=CONSRIGHT(nin);
  651.               continue;
  652.            case TF_INT:
  653.               if(last_int>INTEGER(n)){
  654.             last_int=INTEGER(n);
  655.             nin=CONSRIGHT(nin);
  656.             continue;
  657.               }
  658.               nout->node=NIL;
  659.               nout->type=P_ALLNODE;
  660.               return;
  661.            case TF_FLO:
  662.               if(last_real>(n_real)INTEGER(n)){
  663.             last_real=(n_real)INTEGER(n);
  664.             nin=CONSRIGHT(nin);
  665.             continue;
  666.               }
  667.               nout->node=NIL;
  668.                       nout->type=P_ALLNODE;
  669.                       return;
  670.                 }
  671.              case NT_RATIO:
  672.                 switch(type_flag){
  673.                    case TF_FIRST:
  674.                       last_real=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  675.               type_flag=TF_FLO;
  676.               nin=CONSRIGHT(nin);
  677.                       continue;
  678.                    case TF_INT:
  679.                       last_real=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  680.               if((n_real)last_int>last_real){
  681.             type_flag=TF_FLO;
  682.                         nin=CONSRIGHT(nin);
  683.                         continue;
  684.               }
  685.                       nout->node=NIL;
  686.                       nout->type=P_ALLNODE;
  687.               return;
  688.                    case TF_FLO:
  689.                       tmp=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  690.                       if(last_real>tmp){
  691.                         last_real=tmp;
  692.                         nin=CONSRIGHT(nin);
  693.                         continue;
  694.                       }
  695.               nout->node=NIL;
  696.               nout->type=P_ALLNODE;
  697.                       return;
  698.                 }
  699.              case NT_REAL:
  700.         switch(type_flag){
  701.            case TF_FIRST:
  702.                       last_real=REAL(n);
  703.                       type_flag=TF_FLO;
  704.               nin=CONSRIGHT(nin);
  705.                       continue;
  706.                    case TF_INT:
  707.               if((n_real)last_int>REAL(n)){
  708.                         last_real=REAL(n);
  709.                         type_flag=TF_FLO;
  710.                         nin=CONSRIGHT(nin);
  711.                         continue;
  712.                       }
  713.                       nout->node=NIL;
  714.                       nout->type=P_ALLNODE;
  715.               return;
  716.            case TF_FLO:
  717.                       if(last_real>REAL(n)){
  718.                         last_real=REAL(n);
  719.                         nin=CONSRIGHT(nin);
  720.             continue;
  721.               }
  722.                       nout->node=NIL;
  723.                       nout->type=P_ALLNODE;
  724.               return;
  725.                 }
  726.              default:
  727.            error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  728.          }/* switch */
  729.       }/* if is-value */
  730.       error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  731.    }/* while */
  732.  nout->type=P_ALLNODE;
  733.  nout->node=T;
  734. }
  735.  
  736. void lf_numequal LF_PARAMS
  737. {
  738.  /* controlla se gli argomenti sono tutti uguali */
  739.  
  740.  REGISTER_MOD int    type_flag=TF_FIRST;
  741.  REGISTER_MOD n_type t;
  742.  n_int  last_int;
  743.  n_real last_real;
  744.  node    n;
  745.  
  746.    while(IS_CONS(nin)){
  747.       eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  748.       if( (t=TYPE(n=calc_pointer(nout)))&NT_IS_VALUE){
  749.      switch(t&NT_MASK){
  750.          case NT_INTEGER:
  751.         switch(type_flag){
  752.            case TF_FIRST:
  753.               type_flag=TF_INT;
  754.               last_int=INTEGER(n);
  755.               nin=CONSRIGHT(nin);
  756.               continue;
  757.            case TF_INT:
  758.               if(last_int==INTEGER(n)){
  759.             nin=CONSRIGHT(nin);
  760.             continue;
  761.               }
  762.               nout->node=NIL;
  763.               nout->type=P_ALLNODE;
  764.               return;
  765.            case TF_FLO:
  766.               if(last_real==(n_real)INTEGER(n)){
  767.             nin=CONSRIGHT(nin);
  768.             continue;
  769.               }
  770.               nout->node=NIL;
  771.               nout->type=P_ALLNODE;
  772.               return;
  773.         }
  774.          case NT_RATIO:
  775.         switch(type_flag){
  776.            case TF_FIRST:
  777.               last_real=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  778.               type_flag=TF_FLO;
  779.               nin=CONSRIGHT(nin);
  780.               continue;
  781.            case TF_INT:
  782.               last_real=(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n);
  783.               if((n_real)last_int==last_real){
  784.             type_flag=TF_FLO;
  785.             nin=CONSRIGHT(nin);
  786.             continue;
  787.               }
  788.               nout->node=NIL;
  789.               nout->type=P_ALLNODE;
  790.               return;
  791.            case TF_FLO:
  792.             if(last_real==(n_real)RATIO_NUM(n)/(n_real)RATIO_DEN(n)){
  793.               nin=CONSRIGHT(nin);
  794.               continue;
  795.             }
  796.             nout->node=NIL;
  797.             nout->type=P_ALLNODE;
  798.             return;
  799.         }
  800.          case NT_REAL:
  801.         switch(type_flag){
  802.            case TF_FIRST:
  803.               last_real=REAL(n);
  804.               type_flag=TF_FLO;
  805.               nin=CONSRIGHT(nin);
  806.               continue;
  807.            case TF_INT:
  808.               if((n_real)last_int==(last_real=REAL(n))){
  809.             type_flag=TF_FLO;
  810.             nin=CONSRIGHT(nin);
  811.             continue;
  812.               }
  813.               nout->node=NIL;
  814.               nout->type=P_ALLNODE;
  815.               return;
  816.            case TF_FLO:
  817.               if(last_real==REAL(n)){
  818.             nin=CONSRIGHT(nin);
  819.             continue;
  820.               }
  821.               nout->node=NIL;
  822.               nout->type=P_ALLNODE;
  823.               return;
  824.         }
  825.          default:
  826.            error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  827.      }/* switch */
  828.       }/* if is-value */
  829.       error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  830.    }/* while */
  831.  nout->type=P_ALLNODE;
  832.  nout->node=T;
  833. }
  834.  
  835. /* ----------------------------------------------------------------------- */
  836.  
  837. void lf_and LF_PARAMS
  838. {
  839.  node n=nin;
  840.  
  841.  nout->type=P_ALLNODE;
  842.  nout->node=NIL;
  843.  
  844.  while(nin!=NIL){
  845.     if(IS_CONS(nin)){
  846.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  847.     if(calc_pointer(nout)==NIL)
  848.         return;
  849.     nin=CONSRIGHT(nin);
  850.     continue;
  851.     }
  852.     error(E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  853.  }
  854. }
  855.  
  856. void lf_or LF_PARAMS
  857. {
  858.  node n=nin;
  859.  
  860.  nout->type=P_ALLNODE;
  861.  nout->node=NIL;
  862.  
  863.  while(nin!=NIL){
  864.     if(IS_CONS(nin)){
  865.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  866.     if(calc_pointer(nout)!=NIL)
  867.         return;
  868.     nin=CONSRIGHT(nin);
  869.     continue;
  870.     }
  871.     error(E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&n);
  872.  }
  873. }
  874.  
  875. void lf_not LF_PARAMS
  876. {
  877.  if(IS_CONS(nin)){
  878.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  879.     nout->node=calc_pointer(nout)==NIL?T:NIL;
  880.     nout->type=P_ALLNODE;
  881.     return;
  882.  }
  883.  error(nin==NIL?E_FEWARGS:E_BADLIST,
  884.     ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  885. }
  886.  
  887. void lf_if LF_PARAMS
  888. {
  889.  /* sintassi:  (if sTest sTrue sFalse) */
  890.  /* nin= (Stest sTrue sFalse) */
  891.  
  892.  if(IS_CONS(nin)){
  893.    eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  894.    nin=CONSRIGHT(nin);
  895.    if(IS_CONS(nin)){
  896.      if(calc_pointer(nout)==NIL){
  897.        nin=CONSRIGHT(nin);
  898.        if(IS_CONS(nin)){
  899.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  900.      return;
  901.        }else{
  902.      error(nin==NIL?E_FEWARGS:E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  903.        }
  904.      }else{
  905.        eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  906.        return;
  907.      }
  908.    }else{
  909.      error(nin==NIL?E_FEWARGS:E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  910.    }
  911.  }else{
  912.    error(nin==NIL?E_FEWARGS:E_BADLIST,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  913.  }
  914. }
  915.  
  916. void lf_when LF_PARAMS
  917. {
  918.  /* sintassi:  (when sTest sTrue) */
  919.  /* nin= (Stest sTrue ) */
  920.  node n;
  921.  
  922.  if(IS_CONS(nin)){
  923.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  924.     n=calc_pointer(nout);
  925.     nout->node=NIL;
  926.     nout->type=P_ALLNODE;
  927.     if(n==NIL)return;
  928.     while(IS_CONS(nin=CONSRIGHT(nin))){
  929.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  930.     }
  931.     return;
  932.  }
  933.  error(E_BADLIST,ERR_MNONE|ERR_PVOID|ERR_TBLVL,&nin);
  934. }
  935.  
  936. void lf_unless LF_PARAMS
  937. {
  938.  /* sintassi:  (when sTest sFalse) */
  939.  /* nin= (Stest sFalse ) */
  940.  node n;
  941.  
  942.  if(IS_CONS(nin)){
  943.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  944.     n=calc_pointer(nout);
  945.     nout->node=NIL;
  946.     nout->type=P_ALLNODE;
  947.     if(n!=NIL)return;
  948.     while(IS_CONS(nin=CONSRIGHT(nin))){
  949.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  950.     }
  951.     return;
  952.  }
  953.  error(E_BADLIST,ERR_MNONE|ERR_PVOID|ERR_TBLVL,&nin);
  954. }
  955.